home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga Collections: Bavarian
/
Bavarian #166 (19xx)(APS Electronic).zip
/
Bavarian #166 (19xx)(APS Electronic).adf
/
Mandel-V2.5c.BAS
< prev
next >
Wrap
BASIC Source File
|
1988-08-17
|
22KB
|
687 lines
InitScreen:
CLEAR,30000 : CLEAR,110000&
SCREEN 1,640,200,4,2
WINDOW 1," Mandelbrot - Bilder Version 2.5c 20.3.1988 Dr.W.Friederichs",(0,0)-(631,186),0,1
InitVariables:
DIM f(15,2),old(100,3),hauptbild#(4862),teilbild#(4862),fasqr%(2000)
low=25 : medium=10 : high=1 : resol=low
ra=-2 : re=.5 : ia=-1.25 : ie=1.25 : v=1
farbnum=0 : oldnum=-1
display=0 : hauptbild=1 : teilbild=2 : newpic=0 : teil=0
LoadDataFiles:
ON ERROR GOTO FileNotFound
'----------Laden der Farbpalette
DATA 0,0,0,16,16,16,16,0,0
FOR i=0 TO 2
FOR j=0 TO 2
READ f(i,j)
NEXT j
PALETTE i,f(i,0)/16,f(i,1)/16,f(i,2)/16
NEXT i
'----------Laden der Farbdaten aus Farbdatei
errorcode=0 : OPEN"df0:ManColor" FOR INPUT AS #1
LOCATE 2,1 : COLOR 2,0
IF errorcode=53 THEN
PRINT " Die Farb-Datei [ ManColor ] existiert nicht !"
PRINT " Bitte benutzen Sie die Option 'Farben speichern'"
PRINT " zum Anlegen der Datei"
FOR i=3 TO 15
FOR j=0 TO 2
f(i,j)=10
NEXT j
PALETTE i,f(i,0)/16,f(i,1)/16,f(i,2)/16
NEXT i
ELSE
PRINT " Die Farb-Datei [ ManColor ] wird geladen !"
FOR i=3 TO 15
FOR j=0 TO 2
INPUT #1,f(i,j)
NEXT j
PALETTE i,f(i,0)/16,f(i,1)/16,f(i,2)/16
NEXT i
END IF
CLOSE#1
'----------Laden der Bilderbibliothek
errorcode=0 : OPEN"df0:ManLib" FOR INPUT AS #1
PRINT :PRINT
IF errorcode=53 THEN
PRINT " Die Bibliothek-Datei [ ManLib ] existiert nicht !"
PRINT " Das Anlegen dieser Datei erfolgt automatisch"
OPEN"df0:ManLib" FOR OUTPUT AS #1
CLOSE#1
OPEN"df0:ManLib" FOR INPUT AS #1
ELSE
PRINT " Die Bibliothek-Datei [ ManLib ] wird geladen !"
END IF
WHILE NOT EOF(1)
oldnum=oldnum+1
FOR i=0 TO 3
INPUT#1,old(oldnum,i)
NEXT i
WEND
CLOSE#1
'----------Laden des Hauptbildes
PRINT :PRINT
IF oldnum=-1 THEN
PRINT " Die Bild-Datei [ MainPicture ] existiert nicht !"
PRINT " Bitte legen Sie diese Datei durch Berechnen"
PRINT " eines Bildes mit dem Faktor 1 an"
ELSE
PRINT " Die Bild-Datei [ MainPicture ] wird geladen !"
PRINT " Bitte warten (Ladevorgang dauert etwa 15 sek)"
mra=-2 : mre=.5 : mia=-1.25 : mie=1.25 : mv=1
nr=0 : GOSUB PicLoad
END IF
GOSUB NewColor
ON ERROR GOTO ErrorText
MenuText:
COLOR 1,0
LINE(401,0)-(402,186),1,bf
'----------Farbpalette
LINE(420,0)-(460,24),1,b
FOR j=0 TO 2
LINE(492,8*j)-(620,8*(j+1)),1,b
NEXT j
FOR j=0 TO 15
LINE(425+24*(j MOD 8),29+12*INT(j/8))-(446+24*(j MOD 8),39+12*INT(j/8)),j,bf
NEXT j
LINE(424,28)-(447,40),1,b
LOCATE 1,60:PRINT "R"
LOCATE 2,60:PRINT "G"
LOCATE 3,60:PRINT "B"
LINE(401,54)-(631,54),1
'----------Optionen
FOR j=8 TO 17
LINE(424,8*j-8)-(440,8*j-2),1,b
NEXT j
LOCATE 8,57:PRINT "berechnen bzw. laden"
LOCATE 9,57:PRINT "Aufl"+CHR$(246)+"sung "+CHR$(228)+"ndern"
LOCATE 10,57:PRINT "Bild speichern"
LOCATE 11,57:PRINT "Hardcopy erstellen"
LOCATE 12,57:PRINT "Farben speichern"
LOCATE 13,57:PRINT "Farbanimation an/aus"
LOCATE 14,57:PRINT "Haupt/Teilbild tauschen""
LOCATE 15,57:PRINT "Faktor vergr"+CHR$(246)+CHR$(223)"ern"
LOCATE 16,57:PRINT "Faktor verkleinern"
LOCATE 17,57:PRINT "alte Bilder suchen"
LINE(401,140)-(631,140),1
'----------mathematische Daten
LINE(424,144)-(440,150),1,b
LOCATE 19,57:PRINT "Bildschirm / ";
COLOR 2,0:PRINT "Rechnung"
hhresol=resol : hhra=ra : hhre=re : hhia=ia : hhie=ie : hhv=v
IF display=0 THEN printcolor=2 ELSE printcolor=1
GOSUB PrintData
MouseCheck:
WHILE MOUSE(0)=0:WEND
x=MOUSE(1) : y=MOUSE(2)
WHILE MOUSE(0)><0:WEND
5 IF x<402 THEN
GOSUB ChooseCoord
ELSEIF y<24 AND x>485 AND x<626 THEN
GOSUB ChangeColor
ELSEIF y>28 AND y<52 AND x>424 AND x<614 THEN
GOSUB ChooseColor
ELSEIF y>55 AND y<135 AND x>420 AND x<445 THEN
op=INT(y/8)-6
LINE(425,49+8*op)-(439,53+8*op),2,bf
ON op GOSUB CalcLoad,Resolution,PicSave,HardCopy,ColorSave,RotateColor,SwapPicture,IncFactor,DecFactor,PicShow
LINE(425,49+8*op)-(439,53+8*op),0,bf
ELSEIF y>144 AND y<151 AND x>420 AND x<445 THEN
GOSUB SwapPrintData
END IF
IF NOT maus THEN MouseCheck ELSE maus=0 : GOTO 5
FileNotFound:
errorcode=ERR
RESUME NEXT
ErrorText:
text$=" BASIC-Compiler Error"+STR$(ERR)+" "
GOSUB ShowText
RESUME NEXT
PicShow:
IF display=hauptbild THEN
hv=mv : hra=mra : hre=mre : hia=mia : hie=mie
ELSEIF display=teilbild THEN
hv=pv : hra=pra : hre=pre : hia=pia : hie=pie
ELSE
text$="Es wurde noch kein Hauptbild berechnet !"
GOTO ShowText
END IF
1 found=0 : vloop=2*hv
WHILE vloop<=8192
FOR i=0 TO oldnum
IF old(i,0)=vloop AND old(i,1)>=hra AND old(i,2)>=hia THEN
found=-1 : ra=old(i,1) : ia=old(i,2) : resol=old(i,3)
re=ra+2.5/vloop : ie=ia+2.5/vloop
x1=(ra-hra)*160*hv : x2=x1+400/vloop*hv : IF x2>400 THEN x2=400
y1=(hie-ie)*74.4*hv : y2=y1+186/vloop*hv
LINE(x1,y1)-(x2,y2),1,b
hhresol=resol : hhra=ra : hhre=re : hhia=ia : hhie=ie : hhv=vloop
printcolor=2 : GOSUB PrintData
'----------Mausabfrage
LINE(425,129)-(439,133),0,bf
WHILE MOUSE(0)=0 : WEND
x=MOUSE(1) : y=MOUSE(2)
WHILE MOUSE(0)><0 : WEND
IF display=teilbild THEN
PUT(0,0),teilbild#,PSET
ELSEIF display=hauptbild THEN
PUT(0,0),hauptbild#,PSET
END IF
IF NOT(x>420 AND x<445 AND y>128 AND y<134) THEN
v=vloop
maus=-1
RETURN
END IF
END IF
NEXT i
vloop=2*vloop
WEND
IF found THEN 1
RETURN
CalcLoad:
'---------- Ist MainPicture schon berechnet ?
IF display=0 AND v><1 THEN
LINE(0,0)-(400,186),0,bf
LOCATE 2,1:COLOR 2,0:PRINT " Das erste zu berechnende Bild mu"+CHR$(223)
PRINT " [ MainPicture ] sein ! Bitte w"+CHR$(228)+"hlen Sie den"
PRINT " Vergr"+CHR$(246)+CHR$(223)+"erungsfaktor 1 und starten Sie"
PRINT " die Berechnung des Hauptbildes"
COLOR 1,0
RETURN
END IF
'---------- Altes Bild vorher abspeichern ?
IF newpic AND sure THEN
PUT(0,0),teilbild#,PSET
display=teilbild :sure=0
text$="Gegebenenfalls dieses Bild erst abspeichern"
GOSUB ShowText
PUT(0,0),teilbild#,PSET
LINE(425,57)-(439,61),0,bf
RETURN
END IF
'---------- Von zur Zeit gespeichertem Bild verschieden ?
IF v=pv AND ra=pra AND ia=pia AND resol>=presol THEN
IF (display=hauptbild AND v><1) OR (display=teilbild AND v=1) THEN
GOTO SwapPicture
ELSE
text$="Dieses Bild sehen Sie gerade !!!"
GOTO ShowText
END IF
END IF
'---------- Hauptbild mit anderer Vergroesserung berechnen ?
IF v=1 AND oldnum><-1 AND resol>=old(0,3) THEN
PUT(0,0),hauptbild#,PSET
RETURN
END IF
'---------- Ist Bild auf Diskette gespeichert ?
hhv=v : hhra=ra : hhia=ia
GOSUB LibSearch
IF nr=oldnum+1 OR resol<old(nr,3) THEN Calculation ELSE PicLoad
ChooseCoord:
IF printcolor=1 THEN
IF display=teilbild THEN
v=pv : resol=presol
ELSEIF display=hauptbild THEN
v=mv : resol=mresol
END IF
END IF
IF display=0 THEN
LINE(0,0)-(400,186),0,bf
text$="Vor Koordinatenwahl [ MainPicture ] berechnen !"
GOTO ShowText
ELSEIF display=hauptbild THEN
3 hv=mv : hra=mra : hre=mre : hia=mia : hie=mie
ELSEIF display=teilbild THEN
IF pv>=v THEN GOSUB SwapPicture : GOTO 3
hv=pv : hra=pra : hre=pre : hia=mia : hie=pie
END IF
hhra=ra : hhre=re : hhia=ia : hhie=ie
ra=hra+x/160/hv : re=ra+2.5/v
ie=hie-y/74.4/hv : ia=ie-2.5/v
IF re<=hre AND ia>=hia THEN
LINE(x,y)-(x+400/v*hv,y+186/v*hv),1,b
hhresol=resol : hhra=ra : hhre=re : hhia=ia : hhie=ie : hhv=v
printcolor=2 : GOSUB PrintData
WHILE MOUSE(0)=0 : WEND
x=MOUSE(1) : y=MOUSE(2)
WHILE MOUSE(0)><0 : WEND
IF display=hauptbild THEN
PUT(0,0),hauptbild#,PSET
ELSE
PUT(0,0),teilbild#,PSET
END IF
maus=-1
RETURN
ELSE
ra=hhra : re=hhre : ia=hhia : ie=hhie
END IF
RETURN
IncFactor:
IF printcolor=1 THEN
IF display=hauptbild THEN
resol=mresol : ra=mra : re=mre : ia=mia : ie=mie : v=mv
ELSEIF display=teilbild THEN
resol=presol : ra=pra : re=pre : ia=pia : ie=pie : v=pv
END IF
END IF
IF v<16384 THEN
v=v*2 : re=ra+2.5/v : ie=ia+2.5/v
hhresol=resol : hhra=ra : hhre=re : hhia=ia : hhie=ie : hhv=v
printcolor=2 : GOSUB PrintData
END IF
RETURN
DecFactor:
IF printcolor=1 THEN
IF display=hauptbild THEN
resol=mresol : ra=mra : re=mre : ia=mia : ie=mie : v=mv
ELSEIF display=teilbild THEN
resol=presol : ra=pra : re=pre : ia=pia : ie=pie : v=pv
END IF
END IF
IF v>1 THEN
v=v/2 : re=ra+2.5/v : ie=ia+2.5/v
hhresol=resol : hhra=ra : hhre=re : hhia=ia : hhie=ie : hhv=v
printcolor=2 : GOSUB PrintData
END IF
RETURN
ChangeColor:
j=CINT((y-4)/8)
f(farbnum,j)=CINT((x-492)/8)
IF f(farbnum,j)<0 THEN
f(farbnum,j)=0
ELSEIF f(farbnum,j)>16 THEN
f(farbnum,j)=16
END IF
PALETTE farbnum,f(farbnum,0)/16,f(farbnum,1)/16,f(farbnum,2)/16
GOTO NewColor
ChooseColor:
LINE(424+24*(farbnum MOD 8),28+12*INT(farbnum/8))-(447+24*(farbnum MOD 8),40+12*INT(farbnum/8)),0,b
farbnum=INT((x-426)/24)+8*INT((y-29)/12)
LINE(424+24*(farbnum MOD 8),28+12*INT(farbnum/8))-(447+24*(farbnum MOD 8),40+12*INT(farbnum/8)),1,b
NewColor:
LINE(421,1)-(459,23),farbnum,bf
FOR j=0 TO 2
LINE(494,8*j+2)-(494+7.75*f(farbnum,j),8*j+6),1,bf
LINE(494+7.75*f(farbnum,j),8*j+2)-(618,8*j+6),0,bf
NEXT j
RETURN
Calculation:
LINE(0,0)-(400,186),0,bf
re=ra+2.5/v : ie=ia+2.5/v
hhresol=resol : hhra=ra : hhre=re : hhia=ia : hhie=ie : hhv=v
printcolor=1 : GOSUB PrintData
rs=.006313131#/v*resol : is=.005913878#/v*resol
IF v>64 THEN max%=2000 ELSE max%=200+15*v
max%=max%*2^((resol>high)+(resol>medium))
sqrmax%=SQR(max%)
xp0%=0 : yp0=0
'----------Farbzuordnung
FOR fa%=0 TO sqrmax%
fasqr%(fa%)=3+(fa% MOD 4)
NEXT fa%
FOR fa%=sqrmax% TO max%
fasqr%(fa%)=7+(SQR(fa%) MOD 9)
NEXT fa%
fasqr%(max%)=0
dx%=resol : dy=resol*.44
IF resol=high THEN dy=1 : xp0%=3 : is=is/.44
ypa=yp0 : ype=ypa+dy
FOR i=ie TO ia STEP -is
xpa%=xp0% : xpe%=xpa%+dx%
FOR r=ra TO re STEP rs
real=0
imag=0
realquad=0
imagquad=0
fa%=0
WHILE realquad+imagquad<4 AND fa%<max%
xr=realquad-imagquad+r
imag=2*real*imag+i
real=xr
realquad=xr*xr
imagquad=imag*imag
fa%=fa%+1
WEND
IF MOUSE(0)><0 THEN CalculationStop
LINE(xpa%,ypa)-(xpe%,ype),fasqr%(fa%),bf
xpa%=xpe% : xpe%=xpe%+dx%
NEXT r
ypa=ype : ype=ype+dy
NEXT i
IF v=1 THEN
display=hauptbild
GET(0,0)-(400,186),hauptbild#
mra=ra :mre=re : mia=ia : mie=ie : mv=v : mresol=resol
ELSE
display=teilbild : teil=-1
END IF
GET(0,0)-(400,186),teilbild#
newpic=-1 : sure=-1
pra=ra : pre=re : pia=ia : pie=ie : pv=v : presol=resol
RETURN
CalculationStop:
IF display=hauptbild THEN
display=teilbild
GOSUB SwapPicture
ELSEIF display=teilbild THEN
display=hauptbild
GOSUB SwapPicture
ELSEIF display=0 THEN
LINE(0,0)-(400,186),0,bf
END IF
RETURN
Resolution:
IF printcolor=1 THEN
IF display=hauptbild THEN
resol=mresol : ra=mra : re=mre : ia=mia : ie=mie : v=mv
ELSEIF display=teilbild THEN
resol=presol : ra=pra : re=pre : ia=pia : ie=pie : v=pv
END IF
END IF
IF resol=low THEN
resol=medium
ELSEIF resol=medium THEN
resol=high
ELSEIF resol=high THEN
resol=low
END IF
hhresol=resol : hhra=ra : hhre=re : hhia=ia : hhie=ie : hhv=v
printcolor=2 : GOTO PrintData
RETURN
PicSave:
IF display=0 THEN
LINE(0,0)-(400,186),0,bf
text$="Es existiert kein zu speicherndes Bild !"
GOTO ShowText
ELSEIF display=hauptbild AND newpic THEN
nr=0 : pra=mra : pia=mia : pv=mv : presol=mresol
ELSEIF display=teilbild AND newpic THEN
hhv=pv : hhra=pra : hhia=pia
GOSUB LibSearch
END IF
IF nr><oldnum+1 THEN
IF presol<old(nr,3) THEN
old(nr,3)=presol
OPEN"df0:ManLib" FOR OUTPUT AS #1
FOR i%=0 TO oldnum
PRINT #1,old(i%,0),old(i%,1),old(i%,2),old(i%,3)
NEXT i%
CLOSE#1
ELSE
text$="Dieses Bild existiert bereits"
GOTO ShowText
END IF
ELSE
OPEN"df0:ManLib" FOR APPEND AS #1
PRINT #1,pv,pra,pia,presol
CLOSE#1
oldnum=nr
old(oldnum,0)=pv : old(oldnum,1)=pra : old(oldnum,2)=pia : old(oldnum,3)=presol
END IF
OPEN"df0:ManPicture"+STR$(nr) FOR OUTPUT AS #1
FOR i%=0 TO 4862
PRINT #1,MKD$(teilbild#(i%));
NEXT i%
CLOSE#1
newpic=0
RETURN
ShowText:
tlen2=INT(LEN(text$)/2)
LINE(188-tlen2*8,12)-(204+tlen2*8,27),0,bf
LINE(188-tlen2*8,12)-(204+tlen2*8,27),2,b
LOCATE 3,25-tlen2:COLOR 2,0:PRINT text$:COLOR 1,0
WHILE MOUSE(0)=0 : WEND
x=MOUSE(1) : y=MOUSE(2)
WHILE MOUSE(0)><0 : WEND
IF display=teilbild THEN PUT(0,0),teilbild#,PSET ELSE PUT(0,0),hauptbild#,PSET
maus=-1
RETURN
ColorSave:
OPEN"df0:ManColor" FOR OUTPUT AS #1
FOR i%=3 TO 15
FOR j%=0 TO 2
PRINT #1,f(i%,j%);
NEXT j%
NEXT i%
CLOSE#1
RETURN
InverseColor:
FOR i%=0 TO 15
FOR j%=0 TO 2
f(i%,j%)=16-f(i%,j%)
NEXT j%
PALETTE i%,f(i%,0)/16,f(i%,1)/16,f(i%,2)/16
NEXT i%
RETURN
RotateColor:
weiter=-1
FOR k%=1 TO 13
fh0=f(3,0) : fh1=f(3,1) : fh2=f(3,2)
FOR i%=3 TO 14
FOR j%=0 TO 2
f(i%,j%)=f(i%+1,j%)
NEXT j%
PALETTE i%,f(i%,0)/16,f(i%,1)/16,f(i%,2)/16
IF MOUSE(0)><0 THEN
x=MOUSE(1) : y=MOUSE(2)
weiter=0
LINE(425,97)-(439,101),0,bf
END IF
NEXT i%
f(15,0)=fh0 : f(15,1)=fh1 : f(15,2)=fh2
PALETTE 15,f(15,0)/16,f(15,1)/16,f(15,2)/16
NEXT k%
IF weiter THEN RotateColor
IF x<421 OR x>444 OR y<95 OR y>111 THEN maus=-1
RETURN
PicLoad:
resol=old(nr,3) : newpic=0
OPEN"df0:ManPicture"+STR$(nr) FOR INPUT AS #1
FOR i%=0 TO 4862
teilbild#(i%)=CVD(INPUT$(8,1))
NEXT i%
CLOSE#1
PUT(0,0),teilbild#,PSET
IF nr><0 THEN
hhresol=resol : hhra=ra : hhre=re : hhia=ia : hhie=ie : hhv=v
printcolor=1 : GOSUB PrintData
display=teilbild : teil=-1
pv=v : pra=ra : pre=re : pia=ia : pie=ie : presol=resol
ELSE
GET(0,0)-(400,186),hauptbild#
display=hauptbild : mresol=resol
END IF
RETURN
SwapPicture:
IF display=0 THEN
LINE(0,0)-(400,186),0,bf
text$="Es existiert kein berechnetes Bild !"
GOTO ShowText
ELSEIF display=teilbild THEN
PUT(0,0),hauptbild#,PSET
display=hauptbild
hhresol=mresol : hhra=mra : hhre=mre : hhia=mia : hhie=mie : hhv=mv
printcolor=1 : GOSUB PrintData
ELSEIF display=hauptbild THEN
IF NOT teil THEN
text$="Es existiert kein Teilbild !"
GOTO ShowText
ELSE
PUT(0,0),teilbild#,PSET
display=teilbild
hhresol=presol : hhra=pra : hhre=pre : hhia=pia : hhie=pie : hhv=pv
printcolor=1 : GOSUB PrintData
END IF
END IF
RETURN
LibSearch:
FOR nr=0 TO oldnum
IF old(nr,0)=hhv AND old(nr,1)=hhra AND old(nr,2)=hhia THEN RETURN
NEXT nr
RETURN
SwapPrintData:
IF printcolor=1 THEN
printcolor=2
hhresol=resol : hhra=ra : hhre=re : hhia=ia : hhie=ie : hhv=v
ELSE
printcolor=1
IF display=teilbild THEN
hhresol=presol : hhra=pra : hhre=pre : hhia=pia : hhie=pie : hhv=pv
ELSE
hhresol=mresol : hhra=-2 : hhre=.5 : hhia=-1.25 : hhie=1.25 : hhv=1
IF display=0 THEN printcolor=2
END IF
END IF
PrintData:
IF hhresol=low THEN
res$="niedr."
ELSEIF hhresol=medium THEN
res$="mittel"
ELSEIF hhresol=high THEN
res$="hoch "
END IF
COLOR 1,0:LOCATE 21,53:PRINT "real : ";
COLOR printcolor,0:PRINT USING"##.####";hhra;
COLOR 1,0:PRINT " bis ";
COLOR printcolor,0:PRINT USING"##.####";hhre
COLOR 1,0:LOCATE 22,53:PRINT "imag : ";
COLOR printcolor,0:PRINT USING"##.####";hhia;
COLOR 1,0:PRINT " bis ";
COLOR printcolor,0:PRINT USING"##.####";hhie
COLOR 1,0:LOCATE 23,53:PRINT "Fakt.: ";
COLOR printcolor,0:PRINT USING"#####";hhv;
COLOR 1,0:PRINT " Aufl.: ";
COLOR printcolor,0:PRINT res$;
COLOR 1,0
RETURN
HardCopy:
IF display=hauptbild THEN
hhresol=mresol : hhra=mra : hhre=mre : hhia=mia : hhie=mie : hhv=mv
ELSE
hhresol=presol : hhra=pra : hhre=pre : hhia=pia : hhie=pie : hhv=pv
END IF
printcolor=1 : GOSUB PrintData
GOSUB InverseColor
IF AlreadyDeclared = 0 THEN
DECLARE FUNCTION AllocSignal%() LIBRARY
DECLARE FUNCTION AllocMem&() LIBRARY
DECLARE FUNCTION FindTask&() LIBRARY
DECLARE FUNCTION DoIO&() LIBRARY
DECLARE FUNCTION OpenDevice& LIBRARY
AlreadyDeclared = 1
END IF
sWindow& = WINDOW(7)
sScreen& = PEEKL(sWindow& + 46)
sViewPort& = sScreen& + 44
sRastPort& = sScreen& + 84
sColorMap& = PEEKL(sViewPort& + 4)
maxWidth% = PEEKW(sScreen& + 12)
maxHeight% = PEEKW(sScreen& + 14)
viewModes% = PEEKW(sViewPort& + 32)
command% = 11 'Drucker-Befehls-Nummer
srcX% = 0 'Sende ganzen Screen
srcY% = 0
srcWidth% = maxWidth%
srcHeight% = maxHeight%
destRows& = 0
destCols& = 0
special% = &H84 'FullCol | Aspect
IF BorderFlag% = 0 THEN 'Kein Rahmen
srcX% = srcX% + 3
srcY% = srcY% + 11
srcWidth% = srcWidth% - 3 - 11
srcHeight% = srcHeight% - 11 - 3
END IF
LIBRARY "exec.library"
sigBit% = AllocSignal%(-1)
ClearPublic& = 65537&
msgPort& = AllocMem&(40,ClearPublic&)
IF msgPort& = 0 THEN
PRINT "msgPort nicht allokierbar."
GOTO cleanup4
END IF
POKE(msgPort& + 8), 4 'Type=NT_MSGPORT
POKE(msgPort& + 9), 0 'Priority 0
portName$ = "MyPrtPort"+CHR$(0)
POKEL(msgPort& + 10), SADD(portName$)
POKE(msgPort& + 14), 0 'Flags
POKE(msgPort& + 15), sigBit%
sigTask& = FindTask&(0)
POKEL(msgPort& + 16), sigTask&
CALL AddPort(msgPort&) 'Port hinzufuegen
ioRequest& = AllocMem&(64,ClearPublic&)
IF ioRequest& = 0 THEN
PRINT "ioRequest nicht allokierbar."
GOTO cleanup3
END IF
POKE(ioRequest& + 8),5 'Type=NT_MESSAGE
POKE(ioRequest& + 9),0 'Priority 0
POKEL(ioRequest& + 14), msgPort&
devName$ = "printer.device"+CHR$(0)
pError& = OpenDevice&(SADD(devName$),0,ioRequest&,0)
IF pError& <> 0 THEN
PRINT "Drucker nicht ansprechbar."
GOTO cleanup2
END IF
POKEW(ioRequest& + 28), command%
POKEL(ioRequest& + 32), sRastPort&
POKEL(ioRequest& + 36), sColorMap&
POKEL(ioRequest& + 40), viewModes%
POKEW(ioRequest& + 44), srcX%
POKEW(ioRequest& + 46), srcY%
POKEW(ioRequest& + 48), srcWidth%
POKEW(ioRequest& + 50), srcHeight%
POKEL(ioRequest& + 52), destCols&
POKEL(ioRequest& + 56), destRows&
POKEW(ioRequest& + 60), special%
ioError& = DoIO&(ioRequest&)
IF ioError& <> 0 THEN
PRINT "DumpRPort Fehler =" ioError&
GOTO cleanup1
END IF
cleanup1:
CALL CloseDevice(ioRequest&)
cleanup2:
POKE(ioRequest& + 8), &HFF
POKEL(ioRequest& + 20), -1
POKEL(ioRequest& + 24), -1
CALL FreeMem(ioRequest&,64)
cleanup3:
CALL RemPort(msgPort&)
POKE(msgPort& + 8), &HFF
POKEL(msgPort& + 20), -1
CALL FreeSignal(sigBit%)
CALL FreeMem(msgPort&,40)
cleanup4:
LIBRARY CLOSE
GOTO InverseColor